
' matrizes
DIM GRAYPL(16),CELCNT(16),CLRCNT(16)
DIM OPALETR(16),OPALETG(16),OPALETB(16)
DIM NPALETR(16),NPALETG(16),NPALETB(16)
DIM REALPAL(16),XPNT(8),INVRP(16)

START:
SCREEN 0,0,0: COLOR 0,7 :CLS
 PRINT:PRINT" SamCoupe mode2 (8x1) image converter"
       PRINT" (256x192 bmp 16c - 8/4bit) - 0111292349"
 PRINT:PRINT" Drag a file icon here over this dos-console window and press enter"
 PRINT:PRINT" This converter will generate a binary msx1 screen and a 8bit bmp file"
 PRINT" with the same name from its source":PRINT: PRINT" ";
INPUT F1$
 ON ERROR GOTO START
F1T=LEN(F1$)
  F2$=LEFT$(F1$,F1T-4)+".SA2"
  F3$=LEFT$(F1$,F1T-4)+".BM8"
 OPEN F1$ FOR RANDOM AS #1 LEN=1:F1B$="A":FIELD #1,1 AS FB1$
 OPEN F2$ FOR RANDOM AS #2 LEN=1:F2B$="A":FIELD #2,1 AS FB2$
 OPEN F3$ FOR RANDOM AS #3 LEN=1:F3B$="A":FIELD #3,1 AS FB3$

'---- cabecalho do formato bmp-8bit
DTABMP8HD:
  DATA 66,77,124,192,0,0,0,0,0,0,122,0,0,0,40,0
  DATA 0,0,0,1,0,0,192,0,0,0,1,0,8,0,0,0
  DATA 0,0,0,0,0,0,16,10,0,0,16,10,0,0,17,0
  DATA 0,0,17,0,0,0
  data 0,0,0,0,0,0,0,0,34,204,34,0,34,136,34,0
  data 238,34,34,0,238,102,68,0,34,34,170,0,238,204,68,0
  data 34,34,238,0,102,102,238,0,136,204,204,0,34,204,204,0
  data 34,136,34,0,170,68,204,0,170,170,170,0,238,238,238,0
  data 255,255,255,0
RESTORE DTABMP8HD
  FOR I=1 TO 122:READ GRD:SEEK #3,I:LSET FB3$=CHR$(GRD):PUT #3:NEXT I

'---- bmp source format
   YMPOS= 28+1:GET #1, YMPOS:BITDEPTH=ASC(FB1$)
   YMPOS= 11+1:GET #1, YMPOS:IMSTART=(ASC(FB1$))*256
   YMPOS= 10+1:GET #1, YMPOS:IMSTART=IMSTART+ASC(FB1$)
    PALSZ=INT((IMSTART-54)/4)
ORDEREDPALETTE:
  IF PALSZ>16 THEN PALSZ=16

' preenche matrizes opalet com a paleta do SamCoupe
FOR I=0 TO PALSZ-1
  YMPOS= 54+1+(I*4)
    GET #1, YMPOS+1
      J=INT(ASC(FB1$)/32)
      GRKY=J MOD 2
      OPALETG(I)=J
    GET #1, YMPOS
      J=(INT(ASC(FB1$)/64)*2)+GRKY
      OPALETB(I)=J
    GET #1, YMPOS+2
      J=(INT(ASC(FB1$)/64)*2)+GRKY
      OPALETR(I)=J
 NEXT I
' preenche a paleta que falta
FOR I=PALSZ TO 15
    OPALETR(I)=OPALETR(PALSZ-1)
    OPALETG(I)=OPALETG(PALSZ-1)
    OPALETB(I)=OPALETB(PALSZ-1)
 NEXT I

FOR I=0 TO 15:REALPAL(I)=I:NEXT I

' copia a paleta de 3bit para 8bit
FOR I=0 TO 15
  NPALETG(I)=INT((OPALETG(I)*255)/7)
  NPALETR(I)=INT((OPALETR(I)*255)/7)
  NPALETB(I)=INT((OPALETB(I)*255)/7)
NEXT I

'---- define palette grayscale 
FOR I=0 TO 15
  GPAL=OPALETG(I)
  BPAL=OPALETB(I)
  RPAL=OPALETR(I)
  GRAYPL(I)=((((BPAL*11)+(RPAL*30)+(GPAL*59))*255)/700)
NEXT I

' ---- colour count (important)
  FOR I=0 TO 15:CLRCNT(I)=0:NEXT I
FOR Y1=0 TO 23
      LOCATE 24,2:PRINT USING"###% - 1/2";(Y1*100)/23;
  FOR Y2=0 TO 7
    FOR XP=0 TO 255
        Y=(Y1*8)+Y2:IY=191-Y:XH=INT(XP/2)
          IF BITDEPTH=8 THEN
            YMPOS= IMSTART+1+XP+(IY*256): GET #1, YMPOS
            TCCNT=(ASC(FB1$)) MOD 16
           END IF
          IF BITDEPTH=4 THEN
            YMPOS= IMSTART+1+XH+(IY*128): GET #1, YMPOS
            U1=ASC(FB1$): U2=X2 MOD 2
              IF U2=0 THEN
                U3=240 : U4=16
              END IF
              IF U2=1 THEN
               U3=15:U4=1
              END IF
            TCCNT= INT((U1 AND U3)/U4)
          END IF
            CLRCNT(I)=CLRCNT(I)+TCCNT
    NEXT XP
  NEXT Y2
NEXT Y1

'---- palette correction  (deve ser melhorado)
FOR J=0 TO 16:FOR I=0 TO 14
  IF CLRCNT(I)<CLRCNT(I+1) THEN
    SWAP GRAYPL(I),GRAYPL(I+1)
      SWAP REALPAL(I),REALPAL(I+1)
      SWAP CLRCNT(I),CLRCNT(I+1)
    SWAP OPALETR(I),OPALETR(I+1)
      SWAP OPALETG(I),OPALETG(I+1)
      SWAP OPALETB(I),OPALETB(I+1)
    SWAP NPALETR(I),NPALETR(I+1)
      SWAP NPALETG(I),NPALETG(I+1)
      SWAP NPALETB(I),NPALETB(I+1)
  END IF 
 NEXT I:NEXT J
FOR J=0 TO 8:FOR I=0 TO 6
  IF GRAYPL(I)>GRAYPL(I+1) THEN
    SWAP GRAYPL(I),GRAYPL(I+1)
      SWAP REALPAL(I),REALPAL(I+1)
      SWAP CLRCNT(I),CLRCNT(I+1)
    SWAP OPALETR(I),OPALETR(I+1)
      SWAP OPALETG(I),OPALETG(I+1)
      SWAP OPALETB(I),OPALETB(I+1)
    SWAP NPALETR(I),NPALETR(I+1)
      SWAP NPALETG(I),NPALETG(I+1)
      SWAP NPALETB(I),NPALETB(I+1)
  END IF 
 NEXT I:NEXT J
FOR J=0 TO 8:FOR I=8 TO 14
  IF GRAYPL(I)>GRAYPL(I+1) THEN
    SWAP GRAYPL(I),GRAYPL(I+1)
      SWAP REALPAL(I),REALPAL(I+1)
      SWAP CLRCNT(I),CLRCNT(I+1)
    SWAP OPALETR(I),OPALETR(I+1)
      SWAP OPALETG(I),OPALETG(I+1)
      SWAP OPALETB(I),OPALETB(I+1)
    SWAP NPALETR(I),NPALETR(I+1)
      SWAP NPALETG(I),NPALETG(I+1)
      SWAP NPALETB(I),NPALETB(I+1)
  END IF 
 NEXT I:NEXT J

' criacao de realpal invertido
FOR I=0 TO 15:INVRP(REALPAL(I))=I:NEXT I

' grava a paleta no .mb8
FOR I=0 TO 15
  YMPOS= 54+1+(I*4)
    SEEK #3,YMPOS
     LSET FB3$=CHR$(NPALETB(I))
     PUT #3
    SEEK #3,YMPOS+1
     LSET FB3$=CHR$(NPALETG(I))
     PUT #3
    SEEK #3,YMPOS+2
     LSET FB3$=CHR$(NPALETR(I))
     PUT #3
NEXT I

'----writes SamCoupe screen signature 
SAMPALHEADER:
DATA 0,17,34,127,255
   RESTORE SAMPALHEADER
FOR I=0 TO 4
   READ C
  SEEK #2,1+14352+I:LSET FB2$=CHR$(C):PUT #2
  SEEK #2,1+14372+I:LSET FB2$=CHR$(C):PUT #2
NEXT I

'----writes the palette into the sa2 binary bank 
For I=0 To 15
    OPALB=OPALETB(I)*2:OPALG=OPALETG(I)*2:OPALR=OPALETR(I)*2
        B2=INT((OPALB AND 4)/4)
      R2=INT((OPALR AND 4)/4)
      G2=INT((OPALG AND 4)/4)
        G1=INT((OPALG AND 2)/2)
        B3=INT((OPALB AND 8)/8)
      R3=INT((OPALR AND 8)/8)
      G3=INT((OPALG AND 8)/8)
    OPALSAM=B2+(R2*2)+(G2*4)+(G1*8)+(B3*16)+(R3*32)+(G3*64)
  SEEK #2,1+14336+I:LSET FB2$=CHR$(OPALSAM):PUT #2
  SEEK #2,1+14356+I:LSET FB2$=CHR$(OPALSAM):PUT #2
Next I

'----main loop 
FOR Y1=0 TO 23
     LOCATE 24,2:PRINT USING"###% - 2/2";(Y1*100)/23;
  FOR X1=0 TO 31
    FOR Y2=0 TO 7

'----atribute reading and mounting
       FOR I=0 TO 15:CELCNT(I)=0:NEXT I
      FOR X2=0 TO 7
          Y=(Y1*8)+Y2 
          XP=(X1*8)+X2: IY=191-Y 
        XH=INT(XP/2)
          IF BITDEPTH=8 THEN
            YMPOS= IMSTART+1+XP+(IY*256): GET #1, YMPOS
            XPNT(X2)=INVRP((ASC(FB1$)) MOD 16)
           END IF
          IF BITDEPTH=4 THEN
            YMPOS= IMSTART+1+XH+(IY*128): GET #1, YMPOS
            U1=ASC(FB1$): U2=X2 MOD 2
              IF U2=0 THEN
                U3=240:U4=16
              END IF
              IF U2=1 THEN
               U3=15:U4=1
              END IF
            XPNT(X2)=INVRP( INT((U1 AND U3)/U4))
          END IF
            U=XPNT(X2)   
        CELCNT(U)=CELCNT(U)+1000+(RND(99))
      NEXT X2

        IKATTR=0:PAATTR=0:IKCNT=0:PACNT=0
      FOR I=0 TO 15
	IF IKCNT<CELCNT(I) THEN
          IKCNT=CELCNT(I):IKATTR=I
        END IF 
      NEXT I

        CELCNT(IKATTR)=0
      FOR I=0 TO 15
	IF PACNT<CELCNT(I) THEN
          PACNT=CELCNT(I):PAATTR=I
        END IF 
      NEXT I

        IF IKATTR<PAATTR THEN SWAP IKATTR,PAATTR
      LUMD=(GRAYPL(IKATTR)+GRAYPL(PAATTR))/2
        IKO=INT(IKATTR/8):PAO=INT(PAATTR/8)

              CNTBR0=0
            FOR X2=0 TO 7
              IF XPNT(X2)<8 THEN
                CNTBR0=CNTBR0+1
              END IF
            NEXT X2
              BRATTR=0
              IF CNTBR0<4 THEN BRATTR=1

      IF IKO<>PAO THEN
           DIPTT=9999
         BROK=(BRATTR*8)
           FOR I=0+BROK TO 7+BROK
             DISR=ABS(NPALETR(I)-NPALETR(PAATTR))
             DISG=ABS(NPALETG(I)-NPALETG(PAATTR))
             DISB=ABS(NPALETB(I)-NPALETB(PAATTR))
	     DIST=SQR((DISR^2)+(DISG^2)+(DISB^2))
               IF DIST<DIPTT AND I<>PAATTRS THEN
                 DIPTT=DIST:PAATTRN=I
               END IF
           NEXT I
         PAATTR=PAATTRN
      END IF

'---- reading original 16 colour image as grayscale for screen 2 
      IK8=IKATTR AND 7:PA8=PAATTR AND 7
      IK8PBR=IK8+(BRATTR*8):PA8PBR=PA8+(BRATTR*8)
        PKVAR=0
      FOR X2=0 TO 7
        Y=Y2+(Y1*8):X=X2+(X1*8):IY=191-Y
        U=XPNT(X2)
       'IK=PAATTR
        IK=PA8PBR
	  IF GRAYPL(U)>LUMD THEN
           'IK=IKATTR
            IK=IK8PBR
            PKVAR=PKVAR+(2^(7-X2))
          END IF 
            SEEK #3,123+(IY*256)+X:LSET FB3$=CHR$(IK):PUT #3
      NEXT X2
               ADDQ=X1+(Y2*32)+(y1*256) 
            SEEK #2,1+ADDQ:LSET FB2$=CHR$(PKVAR):PUT #2
              FB2T1=((PA8*8) OR (IK8) OR (BRATTR*64))
            SEEK #2,1+8192+ADDQ:LSET FB2$=CHR$(FB2T1):PUT #2
    NEXT Y2
  NEXT X1
NEXT Y1

   CLOSE #1:CLOSE #2:CLOSE #3
GOTO START
